Read in questionnaire:
filler_items = read.csv("./judgments/all/LikertSkala_filler.csv", fileEncoding = "UTF-8")
test_items = read.csv("./judgments/all/LikertSkala_test.csv", fileEncoding = "UTF-8") %>%
mutate(ITEM_FUNCTION = "test")
questionnaire = bind_rows(filler_items, test_items) %>%
mutate_at(.vars = c("CONDITION_NO","KEY_CONDITION", "workerId"), .funs = as_factor)
We require that at least 90% of the questionnaire has been completed. (Note: we assume that there are no missing trials due to data loss / technical errors).
available_trials = questionnaire %>%
group_by(workerId) %>%
summarise(trials = n(),
trials_prop = n()/length(unique(questionnaire$trial_index))) %>%
mutate(accept = ifelse(trials_prop < 0.9, FALSE, TRUE)) %>%
arrange(trials_prop)
Let’s check whether there are participants that left the questionnaire prematurely:
available_trials %>% filter(trials_prop < 1) %>% kable()
| workerId | trials | trials_prop | accept |
|---|---|---|---|
| 207 | 3 | 0.028 | FALSE |
| 204 | 65 | 0.602 | FALSE |
Remove incomplete data from questionnaire:
questionnaire = questionnaire %>%
filter(!(workerId %in% (
available_trials %>% filter(accept == FALSE) %>% pull(workerId)
)))
We will reject workers with mean(RT) < 3000 ms (as simple spammers) and those with median(RT) < 3000 ms (as clever spammers):
simple_spammer = questionnaire %>%
group_by(workerId) %>%
summarise(score = mean(rt)) %>%
mutate(criterion = "meanRT",
accept = ifelse(score < 3000, FALSE, TRUE))
Are there any simple spammers?
simple_spammer %>% filter(accept == FALSE) %>% kable()
| workerId | score | criterion | accept |
|---|---|---|---|
clever_spammer = questionnaire %>%
group_by(workerId) %>%
summarise(score = median(rt)) %>%
mutate(criterion = "medianRT",
accept = ifelse(score < 3000, FALSE, TRUE))
Are there any clever spammers?
clever_spammer %>% filter(accept == FALSE) %>% kable()
| workerId | score | criterion | accept |
|---|---|---|---|
Participants and different (groups of) items presumably exhibit different RT distributions:
rt_density_worker = questionnaire %>%
ggplot(aes(x=log(rt), group = workerId)) +
geom_density(alpha=.3, fill = "#DFF1FF")
rt_density_item_funs = questionnaire %>%
ggplot(aes(x = log(rt), fill=ITEM_FUNCTION)) +
geom_density(alpha=.3) +
scale_fill_brewer(palette = "Greys")
Figure 1 in Pieper et al. (2022)
The more diverse the distribution the stronger is the superiority of ReMFOD (see next chapter) above generic cutoff points for outlier detection.
Recursive multi-factorial outlier detection (ReMFOD , Pieper et al. (2022))
source("./R Sources/ReMFOD.R")
ReMFOD (see source code) aims at identifying individual trials as genuine intermissions and rushes. In doing so, ReMFOD accounts for different RT distributions of different participants and item functions, as well as swamping and masking effects. Underpinned by these suspicious individual trials, underperforming participants can be determined by means of proportion of trials not responded to wholeheartedly. We propose to discard participants who have responded genuinely to less than 90~% of trials because they supposedly did not meet the task with the necessary seriousness.
To account for different RT distributions, ReMFOD compares the RT of each trial to a lower and an upper cutoff point, which each consider two cutoff criteria, respectively: The first criterion is computed with respect to the group of trials with the same item function (i.e. attention trials only, control trials only, etc.) regardless of the participant responding, the second one is computed with respect to all trials of the corresponding participant (regardless of the item function). Only if an RT surmounts or falls below both criteria, it will be designated as a genuine intermission or as a genuine rush.1
\[\begin{align} \label{eq:cutoff_outlier_rt} \textit{cutoff_}&\textit{intermission} = \max \left\{ \right.\\ &\left. \text{median}(\textit{RTs:participant}) + 2.5 \times \text{mad}(\textit{RTs:participant}), \right.\nonumber\\ &\left. \text{median}(\textit{RTs:item_function}) + 2.5 \times \text{mad}(\textit{RTs:item_function})\right.\nonumber\} \end{align}\]
\[\begin{align} \label{eq:cutoff_guesses_rt} \textit{cutoff_}&\textit{rush} = \min \left\{ \right.\\ &\left. \text{median}(\textit{RTs:participant}) - 1.5 \times \text{mad}(\textit{RTs:participant}), \right.\nonumber\\ &\left. \text{median}(\textit{RTs:item_function}) - 1.5 \times \text{mad}(\textit{RTs:item_function})\right.\nonumber\} \end{align}\]
To account for swamping and masking effects (see Ben-Gal (2005)), the process described above will be repeated on a reduced data set (i.e. excluding already detected outliers) until no more outliers can be found. Therefore, in each iteration step, the cutoff points must be computed afresh.
Different outlier types, computed with respect to different groups, are marked by different shapes: Box-shaped trials are the only RTs we consider as genuine intermissions or rushes. Note that the shapes may overlap as these outliers have been computed by various procedures differing in the groups they included to identify outliers.
## compute different outlier types based on the whole questionnaire and plot these
remfod_plot = questionnaire %>% outlier_plots_remfod()
item_plot = remfod_plot # we are going to reuse remfod_plot for workers
## remove data we are currently not interested in from the plot
item_plot$data = item_plot$data %>%
filter(!ITEM_FUNCTION %in% c("calibration", "filler"))
## structure plot as you like
item_plot + facet_wrap(~ ITEM_FUNCTION, nrow = 1)
We expect that 90 % of the trials are answered without genuine intermission or rushes, i.e. that 90 % of the RTs are valid
rt_outlier_count = remfod(questionnaire) %>%
group_by(workerId, direction) %>% tally() %>%
spread(key = "direction", value = "n") %>%
rename( none = "<NA>") %>%
mutate_if(is.numeric, replace_na, 0) %>%
mutate(trials_total = sum(long, short, none),
prop_long = long/trials_total,
prop_short = short/trials_total,
prop_out = (short+long)/trials_total,
prop_valid = none/trials_total,
accept = ifelse(prop_valid < 0.9, FALSE, TRUE)) %>%
arrange(prop_valid) %>%
mutate_if(is.numeric, round, 4)
Some underperforming participants
Further exemplative workers
control_trials = questionnaire %>%
filter(ITEM_FUNCTION == "control") %>%
droplevels()
attention_trials = questionnaire %>%
filter(ITEM_FUNCTION == "attention") %>%
droplevels()
Each control group should provide chances of less than 5% to pass controls by guessing.
source("./R Sources/GuessingProbs.R")
To compute the probability (by standard binomial expansions) of (exactly!) k correct answers out of N trials, where
we can use the formula (see Frederick & Speed (2007)), implemented by the function k_out_of_N:
\[\begin{align} \label{eq:probs_binomial} \frac{N!}{k!(N - k)!}&p^{k}q^{N-k}\text{, where} \\ p &= \text{ probability of a correct response} \nonumber \\ q &= \text{ probability of an incorrect response} \nonumber \end{align}\]
To compute the probability (by standard binomial expansions) of k or fewer correct answers out of N trials, we can use the function k_out_of_N_cumulative, which returns the sum of all the probabilities from 0 to k (see source code).
Attention trials only exist in ungrammatical conditions, the analysis hence amounts to counting acceptable response.
Let’s look at the chances to answer at least k out of N items correct if three of the options are considered correct, and two incorrect in a 5-pt-LS are considered correct:
k_out_of_N_matrix_cumulative(p = 3/5, Ns = seq(4,16,2), ks = c(2:12))
| N/th> | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 |
|---|---|---|---|---|---|---|---|---|---|---|---|
| 4 | 0.821 | 0.475 | 0.130 | ||||||||
| 6 | 0.959 | 0.821 | 0.544 | 0.233 | 0.047 | ||||||
| 8 | 0.991 | 0.950 | 0.826 | 0.594 | 0.315 | 0.106 | 0.017 | ||||
| 10 | 0.998 | 0.988 | 0.945 | 0.834 | 0.633 | 0.382 | 0.167 | 0.046 | 0.006 | ||
| 12 | 1.000 | 0.997 | 0.985 | 0.943 | 0.842 | 0.665 | 0.438 | 0.225 | 0.083 | 0.020 | 0.002 |
| 14 | 1.000 | 0.999 | 0.996 | 0.982 | 0.942 | 0.850 | 0.692 | 0.486 | 0.279 | 0.124 | 0.040 |
| 16 | 1.000 | 1.000 | 0.999 | 0.995 | 0.981 | 0.942 | 0.858 | 0.716 | 0.527 | 0.329 | 0.167 |
If we assume a probability of less than 5~% to pass a test by chance and combine it with the qualification that not all trials need to be answered correctly, it follows that nine out of ten trials need to be responded to correctly.
If we take the neutral point not to be acceptable, this number is reduced to five correct responses out of six trials:
k_out_of_N_matrix_cumulative(p = 2/5, Ns = seq(4,16,2), ks = c(2:12))
| N/th> | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 |
|---|---|---|---|---|---|---|---|---|---|---|---|
| 4 | 0.525 | 0.179 | 0.026 | ||||||||
| 6 | 0.767 | 0.456 | 0.179 | 0.041 | 0.004 | ||||||
| 8 | 0.894 | 0.685 | 0.406 | 0.174 | 0.050 | 0.009 | 0.001 | ||||
| 10 | 0.954 | 0.833 | 0.618 | 0.367 | 0.166 | 0.055 | 0.012 | 0.002 | 0.000 | ||
| 12 | 0.980 | 0.917 | 0.775 | 0.562 | 0.335 | 0.158 | 0.057 | 0.015 | 0.003 | 0.000 | 0.000 |
| 14 | 0.992 | 0.960 | 0.876 | 0.721 | 0.514 | 0.308 | 0.150 | 0.058 | 0.018 | 0.004 | 0.001 |
| 16 | 0.997 | 0.982 | 0.935 | 0.833 | 0.671 | 0.473 | 0.284 | 0.142 | 0.058 | 0.019 | 0.005 |
As we stick to the positional account for control trials (see Pieper et al. (2022)), we need to evaluate grammatical and ungrammatical trials separately.
On a positional account, the assessment of participants’ performance is carried out separately for grammatical (CONDTION_NO == 1) and ungrammatical (CONDTION_NO == 2) stimuli, focusing on the pertinent side of the scale in each case. We recommend allowing the neutral point as legitimate response to grammatical stimuli but not to ungrammatical stimuli as it does neither reliably indicate the rejection of the grammatical version nor the rejection of the ungrammatical version. The chance to pass control trials is then the joint probability of passing the two groups individually. Regarding our rule of thumb, these shall not exceed 5%.
Let’s have a look at some joint probabilities for up to eight trials per group, where group sizes are equal.
probs_joint = do.call(rbind, lapply(1:8,function(i){
probs_joint_positional(i, 3/5, # N, p grammatical
i, 2/5) #N, p ungrammatical
}))
To receive more balanced options, we further set the constraints that passing grammatical and ungrammatical trials needs to be below 0.6 and that \(k\) needs to be less than \(N\) in both conditions.
probs_joint %>%
filter(joint_probs <= 0.05 & gram_probs < 0.6 & ungram_probs < 0.6) %>%
filter(gram_k < gram_N & ungram_k < ungram_N) %>%
mutate_if(is.numeric, round, digits = 4) %>%
unite(N, gram_N, ungram_N, sep = "-") %>% relocate(N) %>%
arrange(N, ungram_k) %>%
kable(caption = "Table 4 in @Pieper_et_al_2022")
| N | gram_k | gram_probs | ungram_k | ungram_probs | joint_probs |
|---|---|---|---|---|---|
| 5-5 | 4 | 0.337 | 4 | 0.087 | 0.029 |
| 6-6 | 5 | 0.233 | 4 | 0.179 | 0.042 |
| 6-6 | 4 | 0.544 | 5 | 0.041 | 0.022 |
| 6-6 | 5 | 0.233 | 5 | 0.041 | 0.010 |
| 7-7 | 6 | 0.159 | 4 | 0.290 | 0.046 |
| 7-7 | 5 | 0.420 | 5 | 0.096 | 0.040 |
| 7-7 | 6 | 0.159 | 5 | 0.096 | 0.015 |
| 7-7 | 5 | 0.420 | 6 | 0.019 | 0.008 |
| 7-7 | 6 | 0.159 | 6 | 0.019 | 0.003 |
| 8-8 | 7 | 0.106 | 4 | 0.406 | 0.043 |
| 8-8 | 7 | 0.106 | 5 | 0.174 | 0.018 |
| 8-8 | 5 | 0.594 | 6 | 0.050 | 0.030 |
| 8-8 | 6 | 0.315 | 6 | 0.050 | 0.016 |
| 8-8 | 7 | 0.106 | 6 | 0.050 | 0.005 |
| 8-8 | 5 | 0.594 | 7 | 0.009 | 0.005 |
| 8-8 | 6 | 0.315 | 7 | 0.009 | 0.003 |
| 8-8 | 7 | 0.106 | 7 | 0.009 | 0.001 |
There are different ways to proceed: we could evaluate attention and control items as one group, evaluate them separately, and even evaluate related and unrelated control items separately. The best choice may depend on the exact nature of your trials. We are going to compute evaluations based on all groups mentioned.
To facilitate computation, we combine the different groups (named by ITEM_FUNCTION) into a single frame – whereby adapting ITEM_FUNCTION in some cases:
eval_trials = rbind(control_trials, attention_trials) %>%
# attenion or control items evaluated as one group
mutate(ITEM_FUNCTION = "attention|control") %>%
bind_rows(attention_trials) %>%
bind_rows(control_trials) %>%
# separate evaluation of related and unrelated control trials
bind_rows(control_trials %>%
mutate(ITEM_FUNCTION = paste(ITEM_FUNCTION, ITEM_SUBGROUP, sep="_"))
)
Find number of trials in each group (per questionnaire):
Ns = eval_trials %>%
select(ITEM_FUNCTION, CONDITION_NO, itemId) %>%
distinct() %>%
group_by(ITEM_FUNCTION, CONDITION_NO) %>%
tally() %>%
spread(key = CONDITION_NO, value = n, sep = "_") %>%
mutate_if(is.numeric, replace_na, 0)
| ITEM_FUNCTION | CONDITION_NO_1 | CONDITION_NO_2 |
|---|---|---|
| attention | 0 | 12 |
| attention|control | 12 | 24 |
| control | 12 | 12 |
| control_related | 6 | 6 |
| control_unrelated | 6 | 6 |
compute joint probabilities (of passing grammatical and ungrammatical trials):
probs_joint = mapply(probs_joint_positional,
Ns$CONDITION_NO_1, 3/5, Ns$CONDITION_NO_2, 2/5) %>%
t() %>%
as.data.frame() %>%
mutate(ITEM_FUNCTION = Ns$ITEM_FUNCTION) %>%
relocate(ITEM_FUNCTION) %>%
unnest(cols = names(.))
Note: we may now have inbalanced group sizes. Find required k to each group:
eval_criteria = probs_joint %>%
filter(joint_probs <= 0.05) %>%
## do not remove attention
filter((gram_probs < 0.5||gram_probs == 1) & ungram_probs < 0.5) %>%
## do not remove attention
filter((gram_k < gram_N || gram_N == 0) & ungram_k < ungram_N) %>%
mutate_if(is.numeric, round, digits = 3) %>%
group_by(ITEM_FUNCTION) %>%
slice_max(joint_probs)
suggested thresholds (i.e. minimal requirements)
| ITEM_FUNCTION | gram_k | gram_N | gram_probs | ungram_k | ungram_N | ungram_probs | joint_probs |
|---|---|---|---|---|---|---|---|
| attention | 0 | 0 | 1.000 | 9 | 12 | 0.015 | 0.015 |
| attention|control | 9 | 12 | 0.225 | 12 | 24 | 0.213 | 0.048 |
| control | 6 | 12 | 0.842 | 8 | 12 | 0.057 | 0.048 |
| control_related | 5 | 6 | 0.233 | 4 | 6 | 0.179 | 0.042 |
| control_unrelated | 5 | 6 | 0.233 | 4 | 6 | 0.179 | 0.042 |
put in long format:
eval_criteria_long = rbind(
eval_criteria %>%
select(ITEM_FUNCTION, starts_with("gram")) %>%
rename_all(~stringr::str_replace(.,"^gram_","")) %>%
mutate(CONDITION_NO = 1)
,
eval_criteria %>%
select(ITEM_FUNCTION, starts_with("ungram")) %>%
rename_all(~stringr::str_replace(.,"^ungram_","")) %>%
mutate(CONDITION_NO = 2)
) %>%
rowwise() %>%
mutate(prop_k = k/N) %>%
relocate(CONDITION_NO, .after = ITEM_FUNCTION) %>%
arrange(ITEM_FUNCTION)
| ITEM_FUNCTION | CONDITION_NO | k | N | probs | prop_k |
|---|---|---|---|---|---|
| attention | 1 | 0 | 0 | 1.000 | |
| attention | 2 | 9 | 12 | 0.015 | 0.750 |
| attention|control | 1 | 9 | 12 | 0.225 | 0.750 |
| attention|control | 2 | 12 | 24 | 0.213 | 0.500 |
| control | 1 | 6 | 12 | 0.842 | 0.500 |
| control | 2 | 8 | 12 | 0.057 | 0.667 |
| control_related | 1 | 5 | 6 | 0.233 | 0.833 |
| control_related | 2 | 4 | 6 | 0.179 | 0.667 |
| control_unrelated | 1 | 5 | 6 | 0.233 | 0.833 |
| control_unrelated | 2 | 4 | 6 | 0.179 | 0.667 |
count correct responses and compare to number of required correct responses
item_based_eval =
eval_trials %>%
mutate(ANSWER_correct = ifelse(CONDITION_NO == 1, # grammatical
ifelse(ANSWER < 3, "incorrect", "correct"),
#ungrammatical
ifelse(ANSWER < 3, "correct", "incorrect"))) %>%
group_by(workerId, ITEM_FUNCTION, CONDITION_NO, ANSWER_correct) %>%
tally() %>% ungroup(workerId) %>%
spread(key = ANSWER_correct, value = n) %>%
mutate_if(is.numeric, replace_na,0) %>%
## we use proportions in order to deal with potentially missing data
mutate(prop_correct = correct / (correct+incorrect)) %>%
merge(eval_criteria_long) %>%
mutate(accept = ifelse(prop_correct < prop_k, FALSE, TRUE)) %>%
arrange(prop_correct)
Let’s have a look at the criteria we used to evaluate participants:
unique(worker_profile$criterion)
## [1] "progress" "meanRT" "medianRT"
## [4] "validRTs" "attention_2" "attention|control_2"
## [7] "control_2" "control_related_2" "control_unrelated_2"
## [10] "control_related_1" "attention|control_1" "control_1"
## [13] "control_unrelated_1"
If we applied all of those criteria, and reject all participants who failed on any of them, how many participants would we be left with, i.e. accept?
worker_acceptance = worker_profile %>%
select(-score) %>%
group_by(workerId) %>%
summarise(accept = !any(!accept))
table(worker_acceptance$accept)
##
## FALSE TRUE
## 38 34
For convenience, we have (covertly) stored all information gathered in a table named worker_profile. Let’s have a look at how many participants are rejected the individual criteria:
## individual
rejection_reasons = worker_profile %>%
group_by(criterion, accept) %>%
tally() %>%
spread(key = accept, value = n) %>%
rename(acccept = 'TRUE', reject = 'FALSE')
| criterion | reject | acccept |
|---|---|---|
| attention_2 | 30 | 40 |
| attention|control_1 | 2 | 68 |
| attention|control_2 | 5 | 65 |
| control_1 | 70 | |
| control_2 | 9 | 61 |
| control_related_1 | 4 | 66 |
| control_related_2 | 12 | 58 |
| control_unrelated_1 | 1 | 69 |
| control_unrelated_2 | 6 | 64 |
| meanRT | 70 | |
| medianRT | 70 | |
| progress | 2 | 70 |
| validRTs | 9 | 61 |
As expected, many participants fail frequently on attention trials. As opposed to Forced Choice tasks, these can merely measure attention, but cannot draw participants attention to the area of the manipulation (and such improving performance in the future).
Let’s have a look at how these reasons combine, but, for the sake of simplicity, under restrictions to groups as proposed in Pieper et al. (2022), i.e. with separate evaulation of attention and control trials, but joined evaluation of related and unrelated controls.
## Combined Rejection Reasons
rejection_reasons_combined = worker_profile %>%
filter(accept == FALSE) %>%
filter(!grepl("\\|",criterion) & !(grepl("related",criterion))) %>%
group_by(workerId) %>%
arrange(criterion) %>%
summarise(criteria = paste(criterion, collapse = " + ")) %>%
group_by(criteria) %>% tally() %>%
arrange(criteria)
| criteria | n |
|---|---|
| attention_2 | 19 |
| attention_2 + control_2 | 5 |
| attention_2 + control_2 + validRTs | 1 |
| attention_2 + validRTs | 5 |
| control_2 | 1 |
| control_2 + validRTs | 2 |
| progress | 2 |
| validRTs | 1 |
If we do not want to apply certain criteria, we can delete them now from the worker profile:
As we find that enough participants passed attention trials (although it was required that all trials are responded to correctly), we do remove the group attention|control as it is hence not needed (and for illustration purposes):
worker_profile = worker_profile %>%
## restrict to attention and control as groups
filter(!grepl("\\|",criterion) & !(grepl("related",criterion)))
we might also check on individual participants:
worker_profile %>%
mutate(score = ifelse(score > 1,
score/1000, # seconds
score*100) # percent
) %>%
mutate(score = format(round(score, 2), nsmall = 2)) %>%
select(-accept) %>%
spread(key = criterion, value = score) %>%
merge(worker_acceptance) %>% relocate(accept) %>%
mutate(accept = ifelse(accept,"yes","no")) %>%
datatable(rownames = FALSE, extensions = 'Buttons', options = list(
columnDefs = list(list(className = 'dt-right',
targets = 1:(1+length(unique(worker_profile$criterion)))))
))
Rejected Workers:
reject = worker_profile %>%
filter(accept == FALSE) %>%
pull(workerId) %>% unique() %>% sort()
length(reject)
## [1] 36
reject
## [1] 130 131 132 137 138 139 147 148 150 155 158 159 160 170 171 172 174 175 177
## [20] 178 180 181 186 191 192 193 194 202 204 205 207 208 209 211 212 214
## 72 Levels: 128 130 131 132 133 134 135 136 137 138 139 147 148 149 150 ... 215
Remove their data from fillers:
filler_items = filler_items %>%
filter(! workerId %in% reject)
write.csv(filler_items, "./judgments/eligible/LikertSkala_filler.csv", fileEncoding = "UTF-8", row.names = FALSE)
Remove their data from test items:
test_items = test_items %>%
filter(! workerId %in% reject)
write.csv(test_items, "./judgments/eligible/LikertSkala_test.csv", fileEncoding = "UTF-8", row.names = FALSE)
Miller (1991) proposes the values of 3 (very conservative), 2.5 (moderately conservative) or even 2 (poorly conservative). Häussler & Juzek (2016) suggest using an asymmetric criterion (using standard deviations) of -1.5 for the lower and +4 for the upper cutoff point.↩︎